home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / forthcmp.zip / COPIES.4TH < prev    next >
Text File  |  1992-03-30  |  6KB  |  227 lines
  1. \  This program can be used to create new screen files that are composed
  2. \  of other screen files and blank screens. 
  3. \  Copyright (C) 1985, Thomas Almy.  All rights reserved.
  4. \  Users of ForthCMP are given permission to use or distribute this
  5. \  program, as long as no charge is made and the credit message is maintained.
  6.  
  7. 100 MSDOS
  8. INCLUDE VARS
  9. INCLUDE DOS1
  10. DECIMAL
  11. 1024 CONSTANT B/SCR    ( Bytes per Forth screen )
  12. B/SCR 1- NOT CONSTANT BLOCKMASK ( Mask of block size )
  13. VARIABLE JUSTONE    ( TRUE IF ARGS PASSED IN COMMAND LINE )
  14. VARIABLE FILESIZE    ( MAX SCREEN NUMBER IN FILE )
  15. VARIABLE BUFST        ( STARTING ADDRESS OF OUTPUT BUFFER )
  16. VARIABLE BUFP        ( POINTER INTO OUTPUT BUFFER )
  17. VARIABLE BUFE          ( END OF OUTPUT BUFFER )
  18.  
  19. HCB INFILE
  20. HCB OUTFILE
  21.  
  22. VARIABLE CBUF
  23. : EMIT  CBUF C!  stderr CBUF 1 write DROP ;
  24.  
  25. : TYPE  stderr -ROT write DROP ;
  26. : CS:TYPE TYPE ;
  27.  
  28. 0 0 IN/OUT : PROMPT ." > "  ;
  29.  
  30. 0 0 IN/OUT
  31. : CANCEL #TIB @ >IN ! ." (remainder of input line ignored)" CR ;
  32.  
  33. 1 1 IN/OUT
  34. : UPC  ( char -- uppercase.char )
  35.    DUP ASCII a >= IF DUP ASCII z <= IF BL - THEN THEN ;
  36.  
  37. 1 1 IN/OUT
  38. : INRANGE?  ( screen -- successflag )
  39.     FILESIZE @ U> NOT ;
  40.  
  41. 1 0 IN/OUT
  42. : ADD.DEFAULT.EXTENSION ( handle -- )
  43.   2 + DUP >R  1+  ( ext string )
  44.   BEGIN COUNT DUP ASCII . = IF DROP BEGIN COUNT DUP 0=
  45.         IF R> DROP 2DROP EXIT THEN DUP ASCII \ = SWAP ASCII / = OR UNTIL  1 THEN
  46.         0= UNTIL
  47.   DUP 1- ASCII . C<-  ( replace null with dot )
  48.   CNT" SCR"  0 DO COUNT 2 PICK C! SWAP 1+ SWAP LOOP
  49.   DROP ( extension address )
  50.   DUP 0 C<-  ( delimit string )
  51.   R@ - 1- R> C!   ( set length byte )
  52.   ; 
  53.  
  54. 0 0 IN/OUT
  55. : INIT.BUFFER
  56.     DP @ 256 + DUP BUFP !
  57.       BUFST !    ( buffer starts at beginning of free memory )
  58.     S0 @ 128 - BUFST @ -  BLOCKMASK AND  
  59.       BUFST @ + BUFE ! ( end of blocks )
  60. ;
  61.  
  62. 0 0 IN/OUT
  63. : FLUSH.OUT
  64.     OUTFILE BUFST @ BUFP @ BUFST @ - DUP >R FWRITE R> <> IF
  65.             ." ERROR: DISK FULL" OUTFILE FCLOSE bye THEN
  66.     BUFST @ BUFP !
  67. ;
  68.  
  69. 0 0 IN/OUT
  70. : CLOSE.FILE  
  71.     BUFP @ BUFST @ <> IF FLUSH.OUT THEN
  72.         OUTFILE HCB>H stdout <> IF OUTFILE FCLOSE DROP THEN
  73.     ;
  74.  
  75. 0 1 IN/OUT
  76. : WRITE.CHARS ( -- ptr AT WHICH ONE IS TO WRITE B/SCR CHARACTERS )
  77.     BUFE @ BUFP @ = IF FLUSH.OUT THEN
  78.     BUFP @ DUP  B/SCR + BUFP ! ;
  79.  
  80.  
  81. 0 0 IN/OUT
  82. : HELLO
  83.     ." FORTH SCREEN COPY PROGRAM" CR
  84.     ." Copyright (C) 1985 by Thomas Almy.  All rights reserved." CR
  85.     ;
  86.  
  87. 0 0 IN/OUT
  88. : USAGE
  89.     ." USAGE: copies destfile { sourcefile { options }}" CR
  90.     ." where options are:" CR
  91.     ."   +N M-N M- -N or +bN" CR
  92.     ." Use destfile=`-' for standard output" CR
  93.     bye 
  94.     ;
  95.     
  96. 0 0 IN/OUT
  97. : OPEN.FILE
  98.     BL WORD C@ 0= IF USAGE THEN ( file must be specified )
  99.     HELLO
  100.     HERE @ ASCII - 8 << 1+ = IF ( use STD-OUTPUT )
  101.         stdout OUTFILE ! 
  102.     ELSE
  103.             HERE OUTFILE NAME>HCB
  104.         OUTFILE ADD.DEFAULT.EXTENSION 
  105.         OUTFILE O_RD FOPEN 0= IF ( file open successful!)
  106.             OUTFILE FCLOSE DROP ( so close it! )
  107.             ." Destination file exists. Delete?" KEY DUP EMIT CR
  108.             UPC ASCII Y <> IF ." Aborting..." bye THEN
  109.         THEN
  110.         OUTFILE 0 FMAKE  IF ( create failed )
  111.             ." ERROR -- couldn't create destination file" bye THEN
  112.     THEN
  113.     BL WORD C@ IF ( more on command line )
  114.         JUSTONE ON
  115.     ELSE ( no more on command line )
  116.         PROMPT
  117.         QUERY
  118.         BL WORD C@ 0= IF OUTFILE FCLOSE bye THEN
  119.     THEN
  120. ;
  121.  
  122. 0 0 IN/OUT
  123. : GET.COMMAND.LINE
  124.     129 TIB 127 CMOVE
  125.     128 C@ #TIB !
  126.     ;    
  127.  
  128. 0 1 IN/OUT
  129. : GET.COMMAND.WORD ( -- flag , leave word at HERE )
  130.     BL WORD C@ IF -1 ELSE
  131.         JUSTONE @ IF 0 ELSE 
  132.             PROMPT QUERY  BL WORD C@ THEN THEN ;
  133.  
  134. 0 0 IN/OUT
  135. : OPEN.INPUT.FILE
  136.     HERE INFILE NAME>HCB
  137.     INFILE ADD.DEFAULT.EXTENSION
  138.     INFILE O_RD FOPEN IF ( failed )
  139.         ." File " INFILE .FNAME ." not found" CR
  140.             CANCEL  FILESIZE OFF EXIT  THEN 
  141.     INFILE 0 0 2 FSEEK B/SCR M/MOD 1- FILESIZE ! DROP
  142.     ;
  143.  
  144.  
  145. 2 0 IN/OUT
  146. : COPY.SCREENS ( first last -- )
  147.    OVER INRANGE? OVER INRANGE? AND 0= IF
  148.     ." Screens out of range" CR  CANCEL 2DROP 
  149.    ELSE
  150.     2DUP MAX 1+ -ROT MIN 
  151.     INFILE OVER B/SCR M* 0 FSEEK 2DROP 
  152.     DO INFILE WRITE.CHARS B/SCR FREAD B/SCR <> IF ." READ ERROR" THEN LOOP
  153.    THEN 
  154.    ;
  155.  
  156. 1 0 IN/OUT
  157. : COPY.BLANKS  ( count -- )
  158.    0 ?DO  WRITE.CHARS B/SCR BL FILL LOOP
  159.    ;
  160.  
  161. : ATDELIM?  ( dblint ptr valid.delimiter -- int -1 OR 0 )
  162.     SWAP C@ <> IF ." INVALID SPECIFIER: " HERE COUNT TYPE CR
  163.             CANCEL 2DROP 0 
  164.            ELSE DROP -1 
  165.            THEN ;
  166.  
  167. VARIABLE T1  ( Temporaries for INSTR )
  168. VARIABLE T2
  169.  
  170. : INSTR ( countedstring character -- position -1 or 0 )
  171.     T1 C!  ( save character )
  172.     T2 OFF ( found flag )
  173.     COUNT 0 ?DO COUNT T1 C@ = IF I SWAP  T2 ON  LEAVE THEN LOOP
  174.     DROP ( address )  T2 @ ;
  175.  
  176. 1 0 IN/OUT
  177. : RANGE.OF.SCREENS  ( signPosition --- )
  178.         CASE ( depending on sign position )
  179.         0 OF HERE C@ 1 = IF  0 FILESIZE @ COPY.SCREENS ( whole file )
  180.             ELSE 0 0. HERE 1+ CONVERT ( - num )
  181.                  BL ATDELIM? IF COPY.SCREENS THEN
  182.              THEN ENDOF
  183.         HERE C@ 1- OF ( up to end :  NUM - )
  184.             0. HERE CONVERT 
  185.             ASCII - ATDELIM? IF FILESIZE @ COPY.SCREENS THEN ENDOF
  186.         0. HERE CONVERT DUP >R  ASCII - ATDELIM? IF
  187.           0. R> CONVERT BL ATDELIM? IF COPY.SCREENS THEN 
  188.           ELSE R> DROP THEN
  189.     ENDCASE
  190. ;
  191.  
  192. 0 0 IN/OUT
  193. : SINGLE.SCREEN  
  194.         HERE 2+ C@ UPC ASCII B = IF ( blanks )
  195.             0. HERE 2+ CONVERT BL ATDELIM? IF 
  196.                      COPY.BLANKS THEN
  197.         ELSE
  198.             0. HERE 1+ CONVERT BL ATDELIM? IF
  199.                      DUP COPY.SCREENS THEN 
  200.          THEN
  201. ;
  202.  
  203. 0 0 IN/OUT
  204. : EXECUTE.COMMAND 
  205.     HERE ASCII - INSTR IF ( "-" means range of screens )
  206.         RANGE.OF.SCREENS
  207.     ELSE HERE 1+ C@ ASCII + = IF ( single scren or blank screens )
  208.         SINGLE.SCREEN
  209.     ELSE OPEN.INPUT.FILE THEN THEN ;
  210.         
  211. : MAIN   
  212.     INIT.BUFFER
  213.     GET.COMMAND.LINE
  214.     OPEN.FILE
  215.     BEGIN
  216.         EXECUTE.COMMAND
  217.         GET.COMMAND.WORD 0=
  218.     UNTIL
  219.     CLOSE.FILE
  220.     bye
  221.     ;
  222.  
  223. INCLUDE DOS2
  224. INCLUDE FORTHLIB
  225. END
  226.  
  227.